home *** CD-ROM | disk | FTP | other *** search
/ Gigarom 4 / Mac Giga-ROM 4.0 - 1993.toast / FILES / DEV / I-Z / ViewIt™ Shareware.sea / ViewIt™ 2.04 Shareware / Projects / Fortran Demos / FaceProcLF.inc < prev    next >
Text File  |  1992-07-11  |  3KB  |  120 lines
  1. C FaceWare 2.02 Initialization & Dispatching Procedures
  2. C ©FaceWare 1989-92.  All Rights Reserved.
  3.  
  4. C NOTE: To compile this file as a separate object, you'll need
  5. C to add the "!!M Inlines.f" directive seen in the demo program.
  6.  
  7.     SUBROUTINE fJumpIt(theProc,thePtr)
  8.     integer*4 thePtr
  9.     call theProc(%val(thePtr))
  10.     return
  11.     end
  12.  
  13.     SUBROUTINE FaceIt(xPtr,m1,m2,m3,m4,m5)
  14.     implicit none
  15. C NOTE: If you use the "!!G" directive for precompiled globals, add
  16. C our FaceStorLF.inc globals to yours and then remove following line
  17.     include 'FaceStorLF.inc'
  18.       record /FaceRec/ fRec
  19.       common/FaceStuff/fRec
  20.     structure /HeadRec/
  21.       integer*4 addr
  22.       integer*2 baseID
  23.       integer*2 versID
  24.       integer*2 message
  25.       integer*2 resID
  26.       integer*4 fPtr
  27.     end structure
  28.     pointer /HeadRec/ thePtr
  29.     character*4 restype
  30.     integer*4 xPtr,m1,m2,m3,m4,m5,i,fPtr
  31.     thePtr = xPtr
  32.     fPtr = %loc(fRec)
  33.     if (m1 = -61) then
  34.       if ((m4 > -1).and.(.not.BTEST(m4,0))) then
  35.         !ignore spurious mouse & key events
  36.         call FlushEvents(%val(int2(62)),%val(int2(0)))
  37.       end if
  38.       restype = 'FCMD'           !find LoadIt or quit to Finder        
  39.       if (GetResource(%val(restype),%val(int2(1000))) = 0) then
  40.         if (OpenResFile(%val(trim(fRec.uName))) < 0) stop
  41.       end if
  42.       fRec.fFlags = m2         !store FaceIt bit flags
  43.       fRec.xEntries = m5         !store # of table entries
  44.       thePtr = fPtr
  45.       if (m3 > -1) then           !call LoadIt to expand heap?
  46.         call PrepIt(thePtr,m3,0,0,thePtr)
  47.         call fJumpIt(%val(long(thePtr)),thePtr)
  48.       end if
  49.       call PrepIt(thePtr,1100,20,0,thePtr)      !setup fRec header
  50.       call PrepIt(thePtr+552,1130,10,0,thePtr)  !setup dRec header
  51.       call PrepIt(thePtr+1002,1110,20,0,thePtr) !setup uRec header
  52.       call PrepIt(thePtr+1634,1200,20,0,thePtr) !setup vRec header
  53.       fRec.fHead(6) = m4           !store environment type
  54.       fRec.uHead(6) = 2            !establish string type
  55.       thePtr = 0
  56.       if (m4 < -3) return
  57.     end if
  58.     if (m1 = -62) then
  59.       call PrepIt(m2,m3,m4,m5,fPtr)
  60.     else if ((m1 < 0).and.(m1 > -11)) then
  61.       i = (4 * (-1 - m1))
  62.       fRec.xTable(1+i) = m2
  63.       fRec.xTable(2+i) = m3
  64.       fRec.xTable(3+i) = m4
  65.       fRec.xTable(4+i) = m5
  66.     else
  67.       if (thePtr = 0) then       !call to default module?
  68.         thePtr = fPtr + 1002
  69.       else if (thePtr^.fPtr <> fPtr) then
  70.         fRec.cControl = thePtr   !call to control driver?
  71.         thePtr = fPtr + 1634
  72.       end if
  73.       thePtr^.message = 0
  74.       fRec.uCommand = m1         !pass Command & Params
  75.       fRec.uParam(1) = m2
  76.       fRec.uParam(2) = m3
  77.       fRec.uParam(3) = m4
  78.       fRec.uParam(4) = m5
  79.       call fJumpIt(%val(long(thePtr)),thePtr) !jump to FCMD
  80.     end if
  81.     end
  82.  
  83.     SUBROUTINE PrepIt(x,b,v,r,f)
  84.     implicit none
  85. C NOTE: If you use the "!!G" directive for precompiled globals, add
  86. C our FaceStorLF.inc globals to yours and then remove following line
  87.     include 'FaceStorLF.inc'
  88.       record /FaceRec/ fRec
  89.       common/FaceStuff/fRec
  90.     structure /HeadRec/
  91.       integer*4 addr
  92.       integer*2 baseID
  93.       integer*2 versID
  94.       integer*2 message
  95.       integer*2 resID
  96.       integer*4 fPtr
  97.     end structure
  98.     pointer /HeadRec/ x
  99.     integer*4 b,v,r,f,i
  100.     character*4 restype
  101.     restype = 'FCMD'
  102.     x^.addr = long(GetResource(%val(restype),%val(int2(1000))))
  103.     x^.baseID = b
  104.     x^.versID = v
  105.     x^.message = 0
  106.     x^.resID = r
  107.     x^.fPtr = f
  108.     if (fRec.xEntries > 0) then
  109.      do i = 0, fRec.xEntries-1
  110.       if (b = fRec.xTable(1 + 4*i)) then
  111.        if (v = fRec.xTable(2 + 4*i)) then
  112.         if (0 <> fRec.xTable(4 + 4*i)) then
  113.          x^.addr = fRec.xTable(4 + 4*i)
  114.         end if
  115.        end if
  116.       end if
  117.      end do
  118.     end if
  119.     end
  120.